home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / language / forth / jx4a0317.lzh / JAX4TH.I < prev    next >
Text File  |  1994-05-17  |  14KB  |  432 lines
  1. *;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*
  2. *                                    *
  3. *    jax4th.i ... shared includes for JAX4TH                *
  4. *    *C* COPYRIGHT 1991, 1993 jack j. woehr                *
  5. *    jax@well.UUCP JAX on GEnie SYSOP, RCFB (303) 278-0364        *
  6. *                                    *
  7. *;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*;*
  8.  
  9. *--- Register Equates
  10.  
  11. dsp    equr    a7    ; data stack pointer, ptr to "rest of stack"
  12. rp    equr    a6    ; return pointer
  13. ip    equr    a5    ; instruction pointer
  14. bp    equr    a4    ; base pointer to local data space
  15. np    equr    a3    ; next pointer, points to copy of NEXT in local image
  16. cp    equr    a2    ; points to base of resident code space
  17. tos    equr    d7    ; top of stack is "cached"
  18. dp    equr    d6    ; local dictionary pointer
  19. ap    equr    d5    ; allocation pointer to data space
  20.  
  21. *--- Some Other Equates
  22.  
  23. eol        equ    $0a        ; end of line character
  24. charsize    equ    1        ; size of a char in address units
  25. cellsize    equ    4        ; cellsize of our 32-bit Forth
  26. numthreads    equ    4        ; number threads in a voc
  27. vocwidth    equ    ((numthreads*cellsize)+cellsize+cellsize)
  28. ; thread0/thread1/thread2/thread3/voclink/nameptr
  29. numvocs        equ    8        ; max vocs in search order
  30. contextsize    equ    numvocs*cellsize    ; CONTEXT voc ptr array size
  31. namebit        equ    $80        ; mask for start and end of name field
  32. immedbit    equ    $40        ; mask for IMMEDIATE word's count byte
  33. dirtybit    equ    $80000000    ; mask for a BUFFER to be SAVEd
  34. unheader    equ    -1        ; cell-size mask for headerless def
  35. maxncount    equ    $1F        ; max char count in a name header
  36. maxnchar    equ    $7F        ; max ascii value of a name character
  37. kernbit        equ    $80000000    ; mask for kernel token
  38. doflag        equ    $FFFFFFFF    ; compiler security flag
  39. ifflag        equ    $7FFFFFFF    ; compiler security flag
  40. beginflag    equ    $3FFFFFFF    ; compiler security flag
  41. forflag        equ    $1FFFFFFF    ; compiler security flag
  42. whileflag    equ    $0FFFFFFF    ; compiler security flag
  43. elseflag    equ    $07FFFFFF    ; compiler security flag
  44. compflag    equ    $00FFFFFF    ; a general purpose mask
  45. countstrsize    equ    $FF        ; longest counted string
  46. tibsize        equ    $100        ; do signed count bytes exist?
  47. inputsize    equ    $80        ; all we ACCEPT in TIB for now
  48. argarraysize    equ    cellsize*$0D    ; regs for function calls, D0-D6/A0-A5
  49. emitbufsize    equ    $100        ; size of stored ouput strings
  50. dstampsize    equ    cellsize*3    ; AmigaDOS DateStamp
  51. readbuffsize    equ    $1000        ; size of a file read buffer
  52. blockoversize    equ    4        ; bytes in BLOCK overhead
  53. rawblocksize    equ    $400        ; bytes in a BLOCK itself
  54. blocksize    equ    rawblocksize+blockoversize    ; size of a block buffer with overhead
  55. numblockbuffs    equ    2        ; number of BLOCK buffers we'll support
  56. blockbuffsize    equ    blocksize*numblockbuffs    ; two block buffers
  57. charsperline    equ    64        ; characters per line of a screen file
  58. linesperscreen    equ    rawblocksize/charsperline    ; lines in a SCR
  59.  
  60. *--- Macros
  61.  
  62. ;--- Stack Manipulation
  63.  
  64. pshdsp    macro        ; move cached top of stack to data stack.
  65.     move.l    tos,-(dsp)    ; this by itself is DUP
  66.     endm
  67.  
  68. push    macro        ; move tos to dsp and cache arg \1 as tos
  69.     pshdsp
  70.     move.l    \1,tos
  71.     endm
  72.  
  73. popdsp    macro        ; restore top of stack from data stack.
  74.     move.l    (dsp)+,tos    ; this by itself is DROP
  75.     endm
  76.  
  77. pop    macro        ; move tos to \1 and restore tos from dsp
  78.     move.l    tos,\1
  79.     popdsp
  80.     endm
  81.  
  82. rpush    macro        ; push \1 to return stack
  83.     move.l    \1,-(rp)
  84.     endm
  85.  
  86. rpop    macro        ; pop return stack to \1
  87.     move.l    (rp)+,\1
  88.     endm
  89.  
  90. tonext    macro    ; compiled inline at end of code words
  91.     jmp    (np) ; NP will be set to NEXT
  92.     endm
  93.  
  94. nest    macro        ; inline execution engine for colon definition
  95.     rpush    ip    ; save the instruction pointer,
  96.     lea.l    *+6(pc),ip    ; load IP with this word's addr list base addr
  97.     tonext        ; jump next.
  98.     endm
  99.  
  100. ;--- Calling DOS and Exec for Kernel Startup Routines
  101.  
  102. callos    macro        ; call Amiga lib when libptr in A6
  103.     jsr    _LVO\1(rp)    ; jump to offset from lib ptr
  104.     endm
  105.  
  106. callamy    macro    ; \1 Routine \2 Lib Save RP when using lib ptr
  107.     move.l    rp,-(sp)        ; save a6
  108.     move.l    #\2lib,rp    ; get the lib ptr var address
  109.     move.l    0(bp,rp.l),rp    ; get the lib ptr itself into A6
  110.     callos    \1        ; call the routine
  111.     move.l    (sp)+,rp    ; discard lib pointer, restore RP
  112.     push    d0        ; save return val from call
  113.     endm
  114.  
  115. ;--- Some General Tools for User-Specified OS Calls
  116.  
  117. savereg    macro    ; save the Forth engine except the stack & lib pointer and TOS
  118.     movem.l    cp-rp/ap-dp,-(sp)
  119.     endm
  120.  
  121. getreg    macro    ; restore the Forth engine except stack & lib pointers & TOS
  122.     movem.l    (sp)+,ap-dp/cp-rp
  123.     endm
  124.  
  125. getarg    macro    ; load all except stack ptr, tos and lib ptr for an OS call
  126.     push    #argarray
  127.     movem.l    0(bp,d7.l),d0-d6/a0-a5
  128.     popdsp
  129.     endm
  130.  
  131. ;----------------------------------------------------------------------------;
  132. ; Kernel variables are declared at the end of this file. Since ! and @         ;
  133. ; will convert offsets in the data segment to absolute addresses transparent ;
  134. ; to the user, the DOCREATE and DOCONSTANT engines are identical.         ;
  135. ;----------------------------------------------------------------------------;
  136.  
  137. docreat    macro    ; compile dataseg offset + execution engine
  138.     push    #\1            ; push dataseg offset from jax4th.i
  139.     tonext                ; and go NEXT
  140.     endm
  141.  
  142. ;--- Constants in the shared segment use the same execution engine.
  143.  
  144. doconst macro    ; compile literal + execution engine
  145.     push    #\1    ; \1 is the constant value
  146.     tonext    ; return to Forth
  147.     endm
  148.  
  149. ;---------------------------------------------------------------;
  150. ; And Vocabularies use this one. The voc ptr is a DSeg-relative    ;
  151. ; address to be deref'ed like all data access in this Forth.    ;
  152. ;---------------------------------------------------------------;
  153.  
  154. dovoc    macro    ; assemble execution engine for a vocabulary
  155.     move.l    #contextarray,d0
  156.     move.l    #\1,0(bp,d0.l)    ; CONTEXT[0] <- DSeg.forthvoc
  157.     tonext            ; return to Forth
  158.     endm
  159.  
  160. * DOES and UNDOES aren't quite right yet, the stack is messy
  161. * maybe a rp -> a0 ip -> rp a0 ->ip? foof.
  162.  
  163. * dodoes    macro    ; execute hilevel interpreter compiled with does>
  164. *    rpush     (ip)    ; push the ip
  165. *    move.l    (sp)+,ip    ; new ip is waiting on the system stack
  166. *    next        ; jump next
  167. *    endm
  168.  
  169. * undoes    macro    ; return from hilevel to code level
  170. *    rpush    ip    ; hide subroutine return address
  171. *    move.l (sp)+,ip    ; pop system stack to restore ip
  172. *    rts        ; return
  173. *    endm
  174.  
  175. ;--- Stores & Fetches
  176.  
  177. sto    macro    ; addr in tos, data in @sp
  178.     move.l    (sp)+,0(bp,tos.l)
  179.     endm
  180.  
  181. fet    macro    ; addr in tos, returns data in tos
  182.     move.l    0(bp,tos.l),tos
  183.     endm
  184.  
  185. ;--- Block Moves
  186.  
  187. * There is something that should be noted here about byte and
  188. * block moves. CMOVE> actually moves to the left. CMOVE moves
  189. * to the right. The ">" in CMOVE is intended to signify that
  190. * the *data* is moving left (low mem) to right (high mem).
  191. * I have found this confusing!
  192.  
  193. lindex    macro    ; set up indices for data to move left progressing right
  194.     movea.l    bp,a0        ; base address of data segment
  195.     movea.l    bp,a1        
  196.     adda.l    (dsp)+,a1    ; destination
  197.     adda.l    (dsp)+,a0    ; source
  198.     endm
  199.  
  200. rindex    macro    ; set up indices for data to move right progressing left
  201.     lindex
  202.     adda.l    tos,a0        ; add count for backwards move
  203.     adda.l    tos,a1
  204.     endm
  205.  
  206. dmov    macro            ; prepare to move to prevent overlap
  207.     move.l    4(dsp),d0    ; get source
  208.     cmp.l    (dsp),d0    ; destination greater than source?
  209.     endm            ; LT if DEST > SRC
  210.  
  211. ;--- Dictionary Alignment ... these are all forward aligns
  212.  
  213. walin    macro            ; align contents of Dreg to next word boundary
  214.     moveq.l    #0,d0        ; obviously, \1 can't be d0
  215.     lsr.l    #1,\1
  216.     addx.l    d0,\1
  217.     lsl.l    #1,\1
  218.     endm
  219.  
  220. lalin    macro            ; align contents of Dreg to next lword boundary
  221.     moveq.l    #0,d0        ; obviously, \1 can't be d0
  222.     lsr.l    #1,\1
  223.     addx.l    d0,\1
  224.     lsr.l    #1,\1
  225.     addx.l    d0,\1
  226.     lsl.l    #2,\1
  227.     endm
  228.  
  229. apalin    macro            ; align allocation pointer
  230.     lalin    ap
  231.     endm
  232.  
  233. wapalin    macro            ; word align allocation pointer
  234.     walin    ap
  235.     endm
  236.  
  237. dpalin    macro            ; align dictionary pointer
  238.     lalin    dp
  239.     endm
  240.  
  241. wdpalin    macro            ; word align dictionary pointer
  242.     walin    dp
  243.     endm
  244.  
  245. ;--- Relative and Absolute Addressing
  246.  
  247. krn2abs    macro    ; convert a resident kernel image addr token in \1 to abs addr
  248.     lsl.l    #1,\1    ; \1 must be a data reg
  249.     add.l    cp,\1
  250.     endm
  251.  
  252. cod2abs    macro    ; convert a local image code addr token in \1 to abs addr
  253.     lsl.l    #1,\1    ; \1 must be a data reg
  254.     add.l    np,\1
  255.     endm
  256.  
  257. dat2abs    macro    ; convert a local image data addr in \1 to abs addr
  258.     add.l    bp,\1
  259.     endm
  260.  
  261. abs2krn    macro    ; convert abs addr in \1 to resident kernel image addr token
  262.     sub.l    cp,\1
  263.     lsr.l    #1,\1    ; \1 must be a data reg
  264.     ori.l    #kernbit,\1
  265.     endm
  266.  
  267. abs2cod    macro    ; convert abs addr in \1 to local image code addr token
  268.     sub.l    np,\1
  269.     lsr.l    #1,\1    ; \1 must be a data reg
  270.     endm
  271.  
  272. abs2dat    macro    ; convert a local image data addr in \1 to abs addr
  273.     sub.l    bp,\1
  274.     endm
  275.  
  276. ;--- Dictionary and Data Management
  277.  
  278. dicp    macro            ; get the local dictionary pointer
  279.     push    dp        ; to the top of the stack
  280.     endm
  281.  
  282. datp    macro            ; get the local dataseg pointer
  283.     push    ap        ; to the top of stack
  284.     endm
  285.  
  286. ;-----------------------------------------------------------------------;
  287. ; Link Fields will be offsets just like execution tokens, masked in    ;
  288. ; the same manner: right-shifted one bit and masked with $80000000    ;
  289. ; if they reside in the kernel, unmasked in D31 if they are in the    ;
  290. ; local code image.                            ;
  291. ;-----------------------------------------------------------------------;
  292.  
  293. lfa    macro    ; create link field in specified thread
  294.     dc.l    link\1
  295. link\1    set    ((((*-start)-4)>>1)|kernbit)    ; reset the specified link
  296.     endm
  297.  
  298. nfa    macro    ; create name field, count & last char |$80
  299.     ifeq    narg-3
  300.     dc.b    \1|namebit,\2,(\3|namebit)    ; ct, string, nth char
  301.     else
  302.     dc.b    \1|namebit,(\2|namebit)        ; ct, sole char
  303.     endc
  304.     cnop    2    ; word-align start of word
  305.     endm    ; the above may become longword-align for 68020/30
  306.  
  307. nfi    macro    ; create IMMEDIATE name field count & last char |$80
  308.     ifeq    narg-3
  309.     dc.b    \1|namebit|immedbit,\2,(\3|namebit)    ; ct, string, nth char
  310.     else
  311.     dc.b    \1|namebit|immedbit,(\2|namebit)    ; ct, sole char
  312.     endc
  313.     cnop    2    ; word-align start of word
  314.     endm    ; the above may become longword-align for 68020/30
  315.  
  316. headerless    macro    ; so Headerless defs may be recognized by decompiler
  317.     dc.l    -1
  318.     endm
  319.  
  320. exetok    macro    ; execution token in D0, jump to correct machine addr
  321.     lsl.l    #1,d0        ; msb set indicates a kernel token
  322.     bcc.s    1$        ; branch if carry indicates local token
  323.     jmp    0(cp,d0.l)    ; interpret token as a kernel address
  324. 1$    jmp    0(np,d0.l)    ; interpret token as a local address
  325.     endm
  326.  
  327. dereftok    macro    ; \1 is register containing token
  328.     move.l    \1,d0        ; copy to a shift-able register
  329.     lsl.l    #1,d0        ; shift out kernel/local bit
  330.     bcc.s    8$        ; branch if carry indicates local token
  331.     add.l    cp,d0        ; convert kernel token to absolute address
  332.     bra.s    9$
  333. 8$    add.l    np,d0        ; convert local token to absolute address
  334. 9$    move.l    d0,\1
  335.     endm
  336.  
  337. *--- Counted String Assembly
  338.  
  339. ;-----------------------------------------------------------------------;
  340. ; Note that the handling of counted strings in the kernel will be    ;
  341. ; different from the handling of same in the runttime system. BASIS12    ;
  342. ; is somewhat ambiguous about the location of the strings compiled by    ;
  343. ; '"' (quote) ... my intent is that the runtime system will compile    ;
  344. ; them into data space so they may be altered. (The code segment will    ;
  345. ; not be generally readable with "@", etc., nor will the kernel).    ;
  346. ;-----------------------------------------------------------------------;
  347.  
  348. countstr macro    ; "a string" is arg \1
  349.     dc.b    (1$-(*+1))    ; count byte
  350.     dc.b    \1        ; compile string
  351. 1$    cnop    2        ; align dictionary
  352.     endm    
  353.  
  354. *--- Allocating storage in the local image data segment
  355.  
  356. dataptr    set    0    ; keeps track of our local dataseg usage
  357.  
  358. ;--- Perform assembly-time allocation of slots in the local dataseg
  359. ;    which will be constructed/loaded at runtime
  360.  
  361. allocdat    macro
  362. dataptr    set    dataptr+\1    ; \1 is number of bytes
  363.     endm
  364.  
  365. setdat    macro    ; perform allocation as above and SET symbol
  366. \1    set    dataptr        ; \1 is symbolic name
  367.     allocdat    \2    ; \2 is amount of storage
  368.     endm
  369.  
  370. avar    macro    ; make a variable allocation
  371.     setdat    \1,cellsize    ; assign offset
  372.     endm
  373.  
  374. avoc    macro    ; make a vocabulary allocation
  375.     setdat    \1,vocwidth+cellsize    ; one cell extra for backlink
  376.     endm
  377.  
  378. *--- Default variables in each image's data seg
  379.  
  380.     avar    empty    ; holds image dictionary size    
  381.     avar    there    ; holds image data size
  382.     setdat    contextarray,contextsize    ; the CONTEXT array
  383.     avar    stdout    ; I/O handle loaded by startup
  384.     avar    stdin    ; ditto
  385.     avar    appwin    ; -1 = opened NEWCON:  0 = stdio  n = custom win
  386.     setdat    emitbuf,emitbufsize    ; holds chars for output
  387.     avar    base    ; holds numeric base
  388.     avar    doslib    ; holds DOS libptr
  389.     avar    execlib    ; holds Exec libptr
  390.     avoc    forthvoc    ; the FORTH voc thread array
  391.     avoc    impvoc    ; the IMPLEMENTOR voc thread array
  392.     avar    spzero    ; hold initial stack pointer passed by AmigaDOS
  393.     avar    rpzero    ; hold initial return stack allocated at Forth startup
  394. *    avar    rpsize    ; hold user request for rstacksize at next load
  395.     avar    savedimage    ; holds various info for a saved image
  396.     avar    autostart    ; holds autostart vector for a saved image
  397.     avar    state    ; compiling or interpreting?
  398.     avar    span    ; count returned by EXPECT
  399.     avar    ticktib    ; holds address of Terminal Input Buffer
  400.     setdat    tickword,tibsize    ; WORD buffer \ s.b. a MEMALLOC
  401.     setdat    tibuf,tibsize    ; Terminal Input Buffer    \ ditto above
  402.     setdat    sqbuff,tibsize    ; Holds interpreted S" strings
  403.     avar    numtib    ; number of chars read into terminal input buffer
  404.     avar    toin    ; input pointer indexing thru TIB
  405.     setdat    argarray,argarraysize    ; holds reg args for OSCalls
  406.     avar    blk    ; tells which BLOCK being interp'ed or 0 for terminal
  407.     avar    last    ; last word in any wordlist added to dictionary
  408.     avar    width    ; holds max num chars <32 to be saved in name fields
  409.     avar    hld    ; holds number conversion string inset
  410.     avar    dpl    ; holds decimal point place of last number parse
  411.     avar    endq    ; true if at end of input line
  412.     avar    caps    ; true if all input should be converted to uppercase
  413.     avar    istype    ; holds deferral for TYPE
  414.     avar    isemit    ; holds deferral for EMIT
  415.     avar    iswhere    ; holds deferral for WHERE
  416.     avar    isqerror    ; holds deferral for ?ERROR
  417.     avar    catcher        ; head of linked list for CATCH/THROW
  418.     setdat    datestamp,dstampsize    ; holds AmigaDOS DateStamp() return
  419.     avar    current        ; holds CURRENT vocabulary
  420.     avar    tickreadbuff    ; holds abs addr of fileread buffer
  421.     avar    tickblockbuff    ; holds abs addr of base of block buffers
  422.     avar    csp        ; holds stack depth during compilation
  423.     avar    blockfid    ; holds BLOCK file identifier
  424.     avar    sourcefile    ; holds source file identifier
  425.     avar    nonaming    ; TRUE if a :NONAME def is under composition
  426.     avar    voclink        ; holds pointer to last vocab declared
  427.     avar    memtype        ; holds allocation type for mem allocs
  428.     avar    lastblk        ; holds index of most-recently-used BLOCK
  429.     avar    scr        ; holds current SCReen number
  430.  
  431. *--- End of File
  432.